-- regexp-viz - LPP 2010
-- Piotr Bober
-- POSIX extended regular expression (ERE) parser

module Parser
   where

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as T
import Text.ParserCombinators.Parsec.Expr

-- data types for regular expressions

data ERE = Alt ERE ERE
         | Concat ERE ERE
         | OrdChar String
         | QuotedChar String
         | Dot
         | Bracket BracketExpression
         | Anchor String
         | Dupl ERE ERE_Dupl
   deriving Show

data ERE_Dupl = Star
              | Plus
              | QMark
              | DupCount DUP_COUNT
              | DupCountComma DUP_COUNT
              | DupCountCommaSep DUP_COUNT DUP_COUNT
   deriving Show

type DUP_COUNT = Integer

data BracketExpression = Matching BracketList
                       | NonMatching BracketList
   deriving Show

type BracketList = [ExpressionTerm]

type ExpressionTerm = Either SingleExpression Range

data SingleExpression = CS CollatingSymbol
                      | ChC CharacterClass
                      | EqC EquivalenceClass
   deriving Show

data Range = Range CollatingSymbol CollatingSymbol
           | RangeStart CollatingSymbol
   deriving Show

type CollatingSymbol = Either COLL_ELEM META_CHAR

type EquivalenceClass = COLL_ELEM

type CharacterClass = String

type COLL_ELEM = String

type META_CHAR = String

-----------------------------------------------------
-- syntax:
--
-- %token  ORD_CHAR QUOTED_CHAR DUP_COUNT
-- %start  extended_reg_exp
--
--
--
-- extended_reg_exp   : ERE_branch
--                    | extended_reg_exp '|' ERE_branch
--                    ;
--
-- ERE_branch         : ERE_expression
--                    | ERE_branch ERE_expression
--                    ;
--
-- ERE_expression     : one_character_ERE
--                    | '^'
--                    | '$'
--                    | '(' extended_reg_exp ')'
--                    | ERE_expression ERE_dupl_symbol
--                    ;
--
-- one_character_ERE  : ORD_CHAR
--                    | QUOTED_CHAR
--                    | '.'
--                    | bracket_expression
--                    ;
--
-- ERE_dupl_symbol    : '*'
--                    | '+'
--                    | '?'
--                    | '{' DUP_COUNT '}'
--                    | '{' DUP_COUNT ',' '}'
--                    | '{' DUP_COUNT ',' DUP_COUNT '}'
--                    ;
--
-- %token  COLL_ELEM META_CHAR
--
-- %token  OpenEqual EqualClose OpenDot DotClose OpenColon ColonClose
--
-- %token  ClassName
--
-- bracket_expression : '[' matching_list ']'
--                    | '[' nonmatching_list ']'
--                    ;
--
-- matching_list      : bracket_list
--                    ;
--
-- nonmatching_list   : '^' bracket_list
--                    ;
--
-- bracket_list       : follow_list
--                    | follow_list '-'
--                    ;
--
-- follow_list        : expression_term
--                    | follow_list expression_term
--                    ;
--
-- expression_term    : single_expression
--                    | range_expression
--                    ;
--
-- single_expression  : end_range
--                    | character_class
--                    | equivalence_class
--                    ;
--
-- range_expression   : start_range end_range
--                    | start_range '-'
--                    ;
--
-- start_range        : end_range '-'
--                    ;
--
-- end_range          : COLL_ELEM
--                    | collating_symbol
--                    ;
--
-- collating_symbol   : OpenDot COLL_ELEM DotClose
--                    | OpenDot META_CHAR DotClose
--                    ;
--
-- equivalence_class  : OpenEqual COLL_ELEM EqualClose
--                    ;
--
-- character_class    : OpenColon ClassName ColonClose
--                    ;
--
-----------------------------------------------------

----------------- P A R S E R S ---------------------

-----------------------------------------------------

-- language definition

reservedNames :: [String]
reservedNames = ["alnum", "alpha", "blank", "cntrl", "digit", "graph",
                 "lower", "print", "punct", "space", "upper", "xdigit"]

ereLangDef :: T.LanguageDef st
ereLangDef = T.LanguageDef {
   T.commentStart = "",
   T.commentEnd = "",
   T.commentLine = "",
   T.nestedComments = False,
   T.identStart = oneOf "",
   T.identLetter = oneOf "",
   T.opStart = oneOf "*+?[=:.|",
   T.opLetter = oneOf "=:.]",
   T.reservedNames = reservedNames,
   T.reservedOpNames = ["[=","=]","[.",".]","[:",":]","|"],
   T.caseSensitive = True}

lexer = T.makeTokenParser ereLangDef

-- tokens

ordChar :: Parser ERE
ordChar = (noneOf "^][.(){}|\\") >>= return  .  OrdChar  .  (:[])

quotedChar :: Parser ERE
quotedChar =
    choice $ map (\x -> try (symbol x) >>= return  .  QuotedChar)
                 ["\\^", "\\.", "\\[", "\\$", "\\(", "\\)", "\\|", "\\*", "\\+", "\\?", "\\{", "\\\\"]

dupCount :: Parser DUP_COUNT
dupCount = T.natural lexer

collElem :: Parser COLL_ELEM
collElem = (noneOf "^][.(){}|\\") >>= return  .  (:[])

metaChar :: Parser META_CHAR
metaChar =
   symbol "^"
 <|>
   symbol "-"
 <|>
   symbol "]"

reserved :: String -> Parser ()
reserved = T.reserved lexer

className :: Parser CharacterClass
className = (choice $ map (\x -> reserved x >> return x) reservedNames) <?> "class name"

squares :: Parser a -> Parser a
squares = T.squares lexer

braces :: Parser a -> Parser a
braces = T.braces lexer

parens :: Parser a -> Parser a
parens = T.parens lexer

symbol :: String -> Parser String
symbol = T.symbol lexer

reservedOp :: String -> Parser ()
reservedOp = T.reservedOp lexer

dot :: Parser String
dot = T.dot lexer

-- combinators
ereExpr :: Parser ERE      -- na razie sie zapetla
ereExpr =
   try (do
      e <- ereExpr
      d <- ereDuplSymbol
      return $ Dupl e d)
 <|>
   ereSingle

anchor :: Parser ERE
anchor =
   (symbol "^" >>= return  .  Anchor)
 <|>
   (symbol "$" >>= return  .  Anchor)

ereSingle :: Parser ERE
ereSingle =
   ordChar
 <|>
   quotedChar
 <|>
   (dot >> return Dot)
 <|>
   anchor
 <|>
   (bracketExpr >>= return  .  Bracket)
 <|>
   parens ere

opTable = [
   [Postfix $ ereDuplSymbol >>= \d -> return $ \e -> Dupl e d],
   [Infix (return Concat) AssocRight],
   [Infix (reservedOp "|" >> return Alt) AssocRight]]

ere = buildExpressionParser opTable ereSingle

ereDuplSymbol :: Parser ERE_Dupl
ereDuplSymbol =
   do
      symbol "*"
      return Star
 <|>
   do
      symbol "+"
      return Plus
 <|>
   do
      symbol "?"
      return QMark
 <|>
   try (braces dupCount >>= return  .  DupCount)
 <|>
   try
      (braces (do
         d <- dupCount
         symbol ","
         return $ DupCountComma d)
      )
 <|>
   braces (do
      d1 <- dupCount
      symbol ","
      d2 <- dupCount
      return $ DupCountCommaSep d1 d2)

bracketExpr :: Parser BracketExpression
bracketExpr =
   try (squares (symbol "^" >> bracketList) >>= return  .  NonMatching)
 <|>
   (squares bracketList >>= return  .  Matching)
 <?> "bracket expression"


bracketList :: Parser BracketList
bracketList =
   try followList
 <|>
   do
     l <- followList
     symbol "-"
     return l

followList :: Parser BracketList
followList = many1 expressionTerm

expressionTerm :: Parser ExpressionTerm
expressionTerm =
   try (rangeExpr >>= return  .  Right)
 <|>
   (singleExpr >>= return  .  Left)

singleExpr :: Parser SingleExpression
singleExpr =
   (endRange >>= return  .  CS)
 <|>
   (characterClass >>= return  .  ChC)
 <|>
   (equivalenceClass >>= return  .  EqC)

rangeExpr :: Parser Range
rangeExpr =
   try (do
           s <- startRange
           symbol "-"
           return $ RangeStart s
       )
 <|>
   do
      s <- startRange
      t <- endRange
      return $ Range s t

startRange :: Parser CollatingSymbol
startRange =
   do
      r <- endRange
      symbol "-"
      return r

endRange :: Parser CollatingSymbol
endRange =
   (collElem >>= return  .  Left)
 <|>
   collatingSymbol

collatingSymbol :: Parser CollatingSymbol
collatingSymbol =
   do
      reservedOp "[."
      res <- collElemOrMetaChar
      reservedOp ".]"
      return res

collElemOrMetaChar :: Parser CollatingSymbol
collElemOrMetaChar =
   (collElem >>= return  .  Left)
 <|>
   (metaChar >>= return  .  Right)

equivalenceClass :: Parser EquivalenceClass
equivalenceClass =
   do
      reservedOp "[="
      c <- collElem
      reservedOp "=]"
      return c
   <?> "equivalence class"

characterClass :: Parser CharacterClass
characterClass =
   do
      reservedOp "[:"
      c <- className
      reservedOp ":]"
      return c
   <?> "character class"


-----------------------------------------------------------------------------
---------- R U N N I N G ---------------

run :: Show a => Parser a -> String -> IO ()
run p s = case parse p "test" s of
   Left e -> do
                putStr "parse error at "
                print e
   Right x -> print x

test :: String -> IO ()
test = run ere

test1, test2, test3 :: IO ()

test1 = test "[a-zA-Z_][a-zA-Z0-9_]*" -- identifier (Python)

test2 = test "0(x|X)[0-9a-fA-F]+" -- hex integers (Python)

test3 = test "+=|-=|*=|/=|%=|**=|>>=|<<=|&=|^=|\\|=" -- some operators

